#lang racket


(require srfi/13)


;; machine defination
(define MEM-LEN 512)
(define MEM (make-vector MEM-LEN 0))
(define CODE-SEG-BEGIN 0)
(define CODE-SEG-LEN 256)
(define DATA-SEG-BEGIN 256) ; 只要有把握，设成和CODE-SEG-BEGIN相同也可以的
(define DATA-SEG-LEN 256)
(define COINS-REMAIN 2618) ; 每运行一个周期消耗一个币
(define PC			 0)
(define REGSTACK '())
(define CYCLES   0)


;; basic facility
(define (push! x) (set! REGSTACK (cons x REGSTACK)))
(define (pop!)  (let ((result (car REGSTACK))) (set! REGSTACK (cdr REGSTACK)) result))
(define (set-pc! n)  (set! PC n))
(define (pc+!    n)  (set-pc! (+ PC n)))
(define (read-code addr)		(vector-ref MEM (+ addr CODE-SEG-BEGIN)))
(define (get-arg)				(read-code (+ 1 PC)))
(define (get-data addr)		(vector-ref  MEM (+ addr DATA-SEG-BEGIN)))
(define (set-data! addr val)	(vector-set! MEM (+ addr DATA-SEG-BEGIN) val))
(define (get-instr)			(read-code PC))

;; ISA defination
(define ISA
  (list
   ;;     op             code    args  action
   (list 'NOP			 #x0        0 (lambda ()                                                                  (pc+! 1)))

   (list 'PUSH			 #x1        1 (lambda () (push! (get-arg))                                                (pc+! 2)))
   (list 'POP			 #x2        0 (lambda () (pop!)                                                           (pc+! 1)))

   (list 'ADD			 #x11	  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (+ op1 op2)))			(pc+! 1)))
   (list 'SUB			 #x12	  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (- op1 op2)))			(pc+! 1)))
   (list 'MUL			 #x13	  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (* op1 op2)))			(pc+! 1)))
   (list 'DIV			 #x14	  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (/ op1 op2)))			(pc+! 1)))
   (list 'MOD			 #x15	  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (remainder op1 op2)))	(pc+! 1)))

   (list 'AND			 #x21	  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (bitwise-and op1 op2))) (pc+! 1)))
   (list 'OR			 #x22	  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (bitwise-ior op1 op2))) (pc+! 1)))
   (list 'NOT			 #x23	  0 (lambda () (push! (let* ((op1 (pop!)))				(bitwise-not op1)))	(pc+! 1)))

   (list 'EQ			 #x31	  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (if (= op1 op2) 1 0)))	(pc+! 1)))
   (list 'GT			 #x32	  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (if (> op1 op2) 1 0)))	(pc+! 1)))
   (list 'LT			 #x33	  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (if (< op1 op2) 1 0)))	(pc+! 1)))

   (list 'LOAD			 #x41	  1 (lambda () (push! (get-data (get-arg)))									(pc+! 2)))
   (list 'STORE		 #x42	  1 (lambda () (set-data! (get-arg) (pop!))									(pc+! 2)))
   (list 'LOAD_INDIRECT  #x43	  0 (lambda () (let* ((addr (pop!))) (push! (get-data addr)))					(pc+! 1)))
   (list 'STORE_INDIRECT #x44	  0 (lambda () (let* ((addr (pop!)) (val (pop!))) (set-data! addr val))		(pc+! 1)))

   (list 'JUMP			 #x51	  1 (lambda ()					 (set-pc! (get-arg))))
   (list 'JUMPIF		 #x52	  1 (lambda () (if (= (pop!) 0)  (pc+! 2)							 (set-pc! (get-arg)))))

   (list 'PRINT		 #x61	  0 (lambda () (display (pop!)) (display #\newline)                              (pc+! 1)))

   (list 'HALT			 #xff     0 (lambda () #f))
   ))
(define HALT-OPCODE (cadr (assoc 'HALT ISA)))
(define cdr-mapped-ISA (map cdr ISA))



;; '+': 'ADD', '-': 'SUB', '*': 'MUL', '/': 'DIV',
;; '=': 'EQ', '>': 'GT', '<': 'LT', '%': 'MOD',
;; '&': 'AND', '|': 'OR', '~': 'NOT'



(define ALIAS_MAP '((+ ADD)(- SUB) (* MUL) (/ DIV) (% MOD)
					(= EQ) (> GT) (< LT)
					(& AND) (~ NOT)
					(JMP JUMP)
					(HLT HALT)
					))

(define ASSEMBLE
  (lambda (list-of-code)
	(define (tag? val)
	  (and (symbol? val)
		   (let ((cur-str (symbol->string val)))
			 (char=? #\: (string-ref cur-str (- (string-length cur-str) 1))))))

	(define (instruction? val)
	  (assoc val ISA))

    (let* ((tags
			(let loop ((i 0)
					   (L list-of-code)
					   (result '()))
			  (cond ((null? L)
					 result)
					((tag? (car L))
					 (let* ((cur (car L))
							(cur-str (symbol->string (car L)))
							(cur-str-no-colon (string-drop-right cur-str 1)))
					   (loop i (cdr L) (cons `(,(string->symbol cur-str-no-colon) ,i) result))))
					(else
					 (loop (+ i 1) (cdr L) result))))))
      (let loop ((L list-of-code)
				 (reversed-result '()))
		(if (null? L)
			(list->vector (reverse reversed-result))
			(let ((cur-val (car L)))
			 (cond
			   ((number? cur-val)
				(loop (cdr L) (cons cur-val reversed-result)))
			   ((instruction? cur-val)
				(let* ((instr-item (assoc cur-val ISA))
					   (instr-name (car instr-item))
					   (instr-code (cadr instr-item))
					   (arg-num    (caddr instr-item)))
				 (if (= 0 arg-num)
					 (loop (cdr L) (cons instr-code reversed-result))
					 (loop (cddr L)
						   (cons (if (number? (cadr L))
									 (cadr L)
									 (cadr (assoc (cadr L) tags)))
								 (cons (cadr (assoc cur-val ISA)) reversed-result))))))
			   ((assoc cur-val ALIAS_MAP)
				(let ((cur-instr-name (cadr (assoc cur-val ALIAS_MAP))))
				  (loop (cons cur-instr-name (cdr L)) reversed-result)))
			   ((tag? cur-val)
				(loop (cdr L) reversed-result))
			   (else ; == taget
				(loop (cdr L) (cons (cadr (assoc cur-val tags)) reversed-result))))))))))

(define LOADER
  (lambda (BYTE-CODE)
	(vector-copy! MEM CODE-SEG-BEGIN BYTE-CODE)))



(define (dump-machine)
  `((CODE-SEG-BEGIN ,CODE-SEG-BEGIN)
	(CODE-SEG-LEN	,CODE-SEG-LEN  )
	(DATA-SEG-BEGIN ,DATA-SEG-BEGIN)
	(DATA-SEG-LEN	,DATA-SEG-LEN  )
	(PC			,PC		   )
	(REGSTACK		,REGSTACK	   )
	(MEM			,MEM           )
	(COINS-REMAIN	,COINS-REMAIN  )
	(CYCLES         ,CYCLES)))



(define (debug-print)
  (define dasm-list
	(map
	 (lambda (item)
	   `(,(cadr item) ,(car item)))
	 ISA))

  (let* ((instr (get-instr))
		 (item  (assoc instr cdr-mapped-ISA)))
	(if (= (cadr item) 0)
		(display (format "~a\n" `(CYCLES: ,CYCLES REGSTACK: ,REGSTACK instr:  ,(cadr (assoc instr dasm-list)) )))
		(display (format "~a\n" `(CYCLES: ,CYCLES REGSTACK: ,REGSTACK instr:  ,(cadr (assoc instr dasm-list)) ,(get-arg)))))
	))

(define (step-machine!)
  (let* ((instr (get-instr))
		 (item  (assoc instr cdr-mapped-ISA)))
	(debug-print)
	(if (= (cadr item) 0)
		(format "~a\n" `(,instr))
		(format "~a\n" `(,instr ,(get-arg))))
	(cond (item ; 有这指令
		   ((caddr item)))
		  (else ; 没这指令
		   (pc+! 1))))

  (set! COINS-REMAIN (- COINS-REMAIN 1))
  )


(define (RUN-MACHINE)
  (let loop ()
	(cond ((<= COINS-REMAIN 0) ; 没coin了
		   `(NOT-ENOUGH-CONINS ,(dump-machine)))
		  ((>= PC MEM-LEN)
		   (begin
			 (set-pc! 0)
			 (loop)))
		  ((eq? (get-instr) HALT-OPCODE)
		   (format "~a\n" (dump-machine)))
		  (else
		   (step-machine!)
		   (set! CYCLES (+ 1 CYCLES))
		   (loop)))))



(define test-code
  '(

  ;; 初始化：控制变量i=100 → 存入地址100（避免占用目标内存0~99）
  PUSH 100
  STORE 100

  LOOP:									; 循环入口
  ;; 1. 更新i：i = i - 1
  LOAD 100								; 栈：[当前i]
  PUSH 1								; 栈：[当前i, 1]
  SUB									; 栈：[i-1]
  STORE 100								; 更新地址100的i

  ;; 2. 操作内存：MEM[i] = i
  LOAD 100						  ; 栈：[当前i]（待写入的值）
  LOAD 100						  ; 栈：[当前i, 当前i]（待写入的地址）
  STORE_INDIRECT				  ; 执行MEM[地址] = 值

  ;; 3. 终止判断：i==0？若是则跳至PRIME_LEFT
  LOAD 100								; 栈：[当前i]
  PUSH 0								; 栈：[当前i, 0]
  EQ									; 栈：[1若i==0，否则0]
  JUMPIF PRIME_LEFT						; 当i=0时进入素数筛选

  JUMP LOOP								; 否则跳回LOOP入口

  PRIME_LEFT:			  ; 子程序：筛法，将素数留下来
										; 初始化p=2（素数筛选的起始值），存储在地址1
  PUSH 2
  STORE 1								; m[1] = p = 2

  P_LOOP:			  ; p的外层循环入口（p从2到99）
										; 优化：检查p*p是否小于等于100，若大于则结束筛选
  LOAD 1								; 栈：[p]
  LOAD 1								; 栈：[p, p]
  MUL									; 栈：[p*p]
  PUSH 100								; 栈：[p*p, 100]
  GT									; 栈：[1若p*p>100，否则0]
  JUMPIF HALT					   ; 若p*p>100则结束程序，无需继续筛选

										; 检查MEM[p]是否为0（用EQ实现：若等于0则不是素数）
  LOAD 1								; 栈：[p]（地址）
  LOAD_INDIRECT					   ; 栈：[MEM[p]]（获取p地址的值）
  PUSH 0						   ; 栈：[MEM[p], 0]
  EQ							   ; 栈：[1若MEM[p]==0，否则0]
  JUMPIF SKIP_MARK				   ; 若MEM[p]==0（非素数），则跳过标记
										; 能执行到这里，说明MEM[p]≠0（是素数），执行标记倍数
  JUMP MARK_MULTIPLES

  MARK_MULTIPLES:				; 标记p的所有倍数为非素数
										; 计算内循环初始值i = p*p，存储在地址0
  LOAD 1								; 栈：[p]
  LOAD 1								; 栈：[p, p]
  MUL									; 栈：[p*p]
  STORE 0								; m[0] = i = p*p

  I_LOOP:					  ; i的内层循环入口（标记倍数）
										; 检查i是否小于100，若不小于则结束内循环
  LOAD 0								; 栈：[i]
  PUSH 100								; 栈：[i, 100]
  LT									; 栈：[1若i<100，否则0]
  JUMPIF I_CONTINUE						; i<100则继续标记
  JUMP SKIP_MARK						; i>=100则结束内循环

  I_CONTINUE:						   ; 标记当前i为非素数
										; 将MEM[i]设为0（标记为非素数）
  PUSH 0								; 栈：[0]（要存入的值）
  LOAD 0								; 栈：[0, i]（目标地址）
  STORE_INDIRECT						; 执行MEM[i] = 0

										; 更新i = i + p（下一个倍数）
  LOAD 0								; 栈：[i]
  LOAD 1								; 栈：[i, p]
  ADD									; 栈：[i+p]
  STORE 0								; 更新i的值
  JUMP I_LOOP							; 回到内循环入口

  SKIP_MARK:					   ; 跳过标记（或内循环结束后），更新p
										; p = p + 1（下一个待判断的数）
  LOAD 1								; 栈：[p]
  PUSH 1								; 栈：[p, 1]
  ADD									; 栈：[p+1]
  STORE 1								; 更新p的值
  JUMP P_LOOP							; 回到外循环入口

  HALT:									; 程序结束
  HALT


		))


(LOADER
 (ASSEMBLE test-code))

(displayln (dump-machine))

(display
 (RUN-MACHINE))
